unit DbPrgrss;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DB, DbiProcs, DbiTypes;

type
  {data structure  type to save previous callback info}
  TDbiCbInfo = record
    ecbType     : CBType;
    iClientData : longint;
    DataBuffLn  : word;
    DataBuff    : pCBPROGRESSDesc;
    DbiCbFn     : pointer;
  end;
  PDbiCbInfo = ^TDbiCbInfo;

  TDBProgress = class;
  TDBProgressEvent = procedure( Sender: TDBProgress; Msg: string; Percent: integer;
                                var Abort: boolean ) of object;
  TDBProgress = class(TComponent)
  private
    { Private declarations }
    FActive: boolean;
    FDataset: TDataset;
    FOnProgress: TDBProgressEvent;
    FCbDataBuff: CBPROGRESSDesc;  {DBi Structure}
    FOldDbiCbInfo: TDbiCbInfo;    {data structure to save previous callback info}
    FRegHandle: hDBICur;
    procedure SetActive( a: boolean );
    procedure SetDataset( d: TDataset );
  protected
    { Protected declarations }
    procedure RegisterCallback;
    procedure UnregisterCallback;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    { Public declarations }
    destructor Destroy; override;
  published
    { Published declarations }
    property Active: boolean read FActive write SetActive;
    property Dataset: TDataset read FDataset write SetDataset;
    property OnProgress: TDBProgressEvent read FOnProgress write FOnProgress;
  end;

procedure Register;

implementation

{Our callback  function}
function DbiCbFn(ecbType     : CBType;
                 iClientData : Longint;
                 var CbInfo  : pointer): CBRType; export;
var
  abort : boolean;
begin
 {Check to see if the callback type is what we expect}
  result := cbrUSEDEF;
  if ecbType = cbGENPROGRESS then
    with TDBProgress(iClientData) do
    begin
      result := cbrCONTINUE;
      abort := false;
      if assigned(FOnProgress) then
        FOnProgress(TDBProgress(iClientData),StrPas(pCBPROGRESSDesc(@cbInfo)^.szMsg),
                    pCBPROGRESSDesc(@cbInfo)^.iPercentDone,abort);
     {was there a previous callback registered}
     {if so - call it and return}
      if FOldDbiCbInfo.DbiCbFn <> nil then
        result := pfDBICallBack(FOldDbiCbInfo.DbiCbFn)
                    (ecbType, FOldDbiCbInfo.iClientData, cbInfo);
      if abort then result := cbrABORT;
    end;
end;

procedure TDBProgress.RegisterCallback;
begin
  if csDesigning in ComponentState then exit;
 {get info about any installed callback}
  if FDataset<>nil then FRegHandle := FDataset.Handle
                   else FRegHandle := nil;
  DbiGetCallBack(FRegHandle,
                 cbGENPROGRESS,
                 FOldDbiCbInfo.iClientData,
                 FOldDbiCbInfo.DataBuffLn,
                 pointer(FOldDbiCbInfo.DataBuff),
                 @FOldDbiCbInfo.DbiCbFn);
 {register our callback}
  Check(DbiRegisterCallBack(FRegHandle,
                      cbGENPROGRESS,
                      longint(Self),
                      SizeOf(FcbDataBuff),
                      @FcbDataBuff,
                      DbiCbFn));
end;

procedure TDBProgress.UnregisterCallback;
begin
  if (csDesigning in ComponentState) or not FActive then exit;
  {if a previous callback exists - reinstall it else}
  {unregister our callback}
  if FOldDbiCbInfo.DbiCbFn <> nil then
    Check(DbiRegisterCallBack(FRegHandle,
                        cbGENPROGRESS,
                        FOldDbiCbInfo.iClientData,
                        FOldDbiCbInfo.DataBuffLn,
                        FOldDbiCbInfo.DataBuff,
                        pfDBICallBack(FOldDbiCbInfo.DbiCbFn)))
  else
    Check(DbiRegisterCallBack(FRegHandle,
                        cbGENPROGRESS,
                        longint(@FOldDbiCbInfo),
                        SizeOf(FcbDataBuff),
                        @FcbDataBuff,
                        nil));
  FOldDbiCbInfo.DbiCbFn := nil;
end;

procedure TDBProgress.SetActive( a: boolean );
begin
  if FActive=a then exit;
  UnregisterCallback;
  if a then RegisterCallback;
  FActive := a;
end;

procedure TDBProgress.SetDataset( d: TDataset );
begin
  if FDataset=d then exit;
  UnregisterCallback;
  FDataset := d;
  if FActive then RegisterCallback;
end;

procedure TDBProgress.Loaded;
begin
  inherited Loaded;
  if FActive then RegisterCallback;
end;

procedure TDBProgress.Notification(AComponent: TComponent; Operation: TOperation); 
begin
  inherited Notification(AComponent,Operation);
  if (AComponent=FDataset) and (Operation=opRemove) then
    Dataset := nil;
end;

destructor TDBProgress.Destroy;
begin
  UnregisterCallback;
  inherited Destroy;
end;

procedure Register;
begin
  RegisterComponents('DCF', [TDBProgress]);
end;

end.
